home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / primops / mipslow.t < prev    next >
Encoding:
Text File  |  1989-06-30  |  6.7 KB  |  199 lines
  1. (herald mipslow
  2.   (env (*value orbit-env 'base-early-binding-env) constants primops arith locations))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27.  
  28. (define-constant (return . args) 
  29.   (ignore args)
  30.   (lap ()                           
  31.     (jr link-reg)           
  32.     (sub nargs zero nargs)))
  33.  
  34. (declare simplifier return simplify-values)
  35.  
  36. (define-constant (receive-values recipient thunk) 
  37.   (ignore recipient thunk)
  38.   (lap ()
  39.     (sub ($ 8) sp)
  40.     (store l link-reg (d@r sp 4))
  41.     (store l A1 (d@r sp 0))                       ; push "recipient"
  42.     (move A2 P)                      ; prepare to call thunk
  43.     (move ($ 1) NARGS)               ; thunk takes no arguments
  44.     (load l (d@nil slink/icall) extra)
  45.     (jalr extra)
  46.     (add ($ 12) link-reg)
  47.     (template 1 -1 t)
  48.     (load l (d@r SP 0) P)              ; prepare to call recipient
  49.     (load l (d@r sp 4) link-reg)
  50.     (add ($ 8) SP)            ; restore continuation
  51.     (load l (d@nil slink/icall) extra)
  52.     (jr extra)
  53.     (sub NARGS zero NARGS)))              ; !!
  54.  
  55.  
  56. (declare simplifier receive-values simplify-receive-values)
  57.  
  58. (define-constant make-pointer        ; extend and number of bytes
  59.   (primop make-pointer ()                                        
  60.     ((primop.generate self node)
  61.      (generate-make-pointer node))
  62.     ((primop.type self node)
  63.      '#[type (proc #f (proc #f top) top fixnum)])))
  64. ;     '#[type (proc #f (proc #f top) extend fixnum)])))
  65.  
  66.  
  67. (define-constant slink-ref
  68.   (primop slink-ref ()
  69.     ((primop.generate self node)
  70.      (generate-slink-ref node))))
  71.  
  72. (define-constant set-slink-ref
  73.   (primop set-slink-ref ()
  74.     ((primop.side-effects? self) t)
  75.     ((primop.generate self node)
  76.      (generate-set-slink-ref node))))
  77.  
  78. (define-constant system-global
  79.   (object (lambda (i) (slink-ref i))
  80.     ((setter self)
  81.      (lambda (i val) (set-slink-ref i val)))))
  82.  
  83.  
  84.  
  85. ;; template junk, see template.doc
  86.  
  87. (define-constant template-enclosing-object
  88.   (primop template-enclosing-object ()
  89.     ((primop.generate self node)
  90.      (generate-template-enclosing-object node))
  91.     ((primop.type self node)
  92.      '#[type (proc #f (proc #f top) template)])))
  93.  
  94. (define-constant gc-extend->pair
  95.   (primop gc-extend->pair ()
  96.     ((primop.generate self node)
  97.      (generate-one-arg node (lambda (acc t-reg)
  98.                   (emit risc/add (machine-num 1) acc t-reg))))
  99.     ((primop.type self node)
  100.      '#[type (proc #f (proc #f top) top)])))
  101. ;     '#[type (proc #f (proc #f pair) extend)])))
  102.  
  103. (define-constant gc-pair->extend
  104.   (primop gc-pair->extend ()
  105.     ((primop.generate self node)
  106.      (generate-one-arg node (lambda (acc t-reg)
  107.                   (emit risc/sub (machine-num 1) acc t-reg))))
  108.     ((primop.type self node)
  109.      '#[type (proc #f (proc #f top) top)])))
  110. ;     '#[type (proc #f (proc #f extend) pair)])))
  111.     
  112. (define-constant closure-enclosing-object
  113.   (primop closure-enclosing-object ()
  114.     ((primop.generate self node)
  115.      (generate-closure-enclosing-object node))
  116.     ((primop.type self node)
  117.      '#[type (proc #f (proc #f top) top)])))
  118. ;     '#[type (proc #f (proc #f top) extend)])))
  119.  
  120. (define-constant frame-header
  121.   (primop frame-header ()
  122.     ((primop.generate self node)
  123.      (generate-frame-header node))))
  124.  
  125. (define-constant frame-sp
  126.   (primop frame-sp ()
  127.     ((primop.generate self node)
  128.      (generate-frame-sp node))))
  129.  
  130. (define-constant stack-pointer
  131.   (primop stack-pointer ()
  132.     ((primop.generate self node)
  133.      (generate-stack-pointer node))))
  134.  
  135. ; see template.doc
  136.                                                     
  137. (define-constant (bit-test operand bit)    ; true if bit is on
  138.   (if (fixnum-equal? (fixnum-logand operand (fixnum-ashl 1 bit)) 0)
  139.       '#f
  140.       '#t))
  141.  
  142. (define-constant (template-internal-bit? tem)          
  143.   (let ((tem (if (fixnum-equal? (template-nargs tem) 0)
  144.                  (extend-pointer-elt tem 0)
  145.                  tem)))
  146.     (bit-test (mref-16-u tem (fixnum-add -2 template/annotation)) 0)))
  147.  
  148. (define-constant (template-superior-bit? tem) '#f)
  149.                                     
  150. (define-constant (template-nary? tem)
  151.   (alt-bit-set? tem))
  152.  
  153. (define-constant (template-pointer-slots tem)
  154.   (mref-16-u tem (fixnum-add -2 template/pointer)))
  155.  
  156. (define-constant (template-scratch-slots tem) 0)
  157.  
  158. (define-constant (template-nargs tem)
  159.   (mref-8-s tem (fixnum-add -2 template/nargs)))
  160.  
  161. (define-constant (template-encloser-offset template)
  162.   (fixnum-ashr (mref-integer template (fixnum-add -2 template/offset)) 2))
  163.  
  164. (define-constant (template-handler-offset template)
  165.   (mref-16-u template (fixnum-add -2 template/handler)))
  166.  
  167. (define-constant (closure-encloser-offset closure)
  168.   (fixnum-ashr (mref-16-u (extend-header closure) (fixnum-add -2 template/pointer)) 2))
  169.  
  170. (define-constant (unit-top-level-forms unit)
  171.   (make-pointer unit 3))
  172.  
  173. (define-constant (alt-bit-set? extend)            ; if bit 7 of header is on
  174.   (fixnum-less? (mref-8-s extend (fixnum-add -2 template/header)) 0))
  175.  
  176. (define-constant (set-alt-bit! x)
  177.   (modify (mref-8-u x (fixnum-add -2 template/header))
  178.       (lambda (x) (fixnum-logior #b10000000 x))))
  179.  
  180. (define-constant (clear-alt-bit! x)
  181.   (modify (mref-8-u x (fixnum-add -2 template/header))
  182.       (lambda (x) (fixnum-logand #b01111111 x))))
  183.  
  184.  
  185. (define-constant vcell-defined? alt-bit-set?)
  186.  
  187. (define-constant set-vcell-defined set-alt-bit!)
  188.  
  189. (define-constant set-vcell-undefined clear-alt-bit!)
  190.  
  191. (define-constant pure? alt-bit-set?)
  192.  
  193. (define-constant (purify! x)
  194.   (set-alt-bit! x)
  195.   (return))
  196.                        
  197.  
  198.  
  199.